home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
007
/
tools.pqs
/
tools.pas
Wrap
Pascal/Delphi Source File
|
1984-12-17
|
12KB
|
456 lines
{
TOOLS.PAS - Screen & I/O Tools for MS and IBM Pascal
copyright 1984 Ronald Florence
WRXY - writes an lstring, with specified screen attribute, at row/col
DOXY - sets a row/col/len to a char and screen attribute
CLS - clears from 1 to 25 rows of the screen
LOCATE - places cursor at a row/col (1..25, 1..80)
CURSOR_ROW, CURSOR_COL - returns cursor location (1..25, 1..80)
INKEY - returns the next char pressed
ESCAPE - returns true if Esc is pressed
RDCHAR - waits for a char in a declared set
YES - waits for y/n; returns true if y
UPCASE - changes a string to upper case
RDSTR - inputs a string
RDINT - inputs an integer between low/high
RDREAL - inputs a decimal real
(RDSTR, RDINT, RDREAL all clear and start over if Esc is pressed during
entry. If Esc is pressed with no entry, they return false. All three
need a writeln if used in tty-type entry. Usage:
var i: integer;
begin
write ('Prompt: ');
if not rdint (i, -1, 100) then return;
writeln; )
PEEK, POKE - segmented direct address procedure/functions
OK_DISP - sets video address, returns false if not 80 col text display
PUSHSCREEN - saves current screen
POPSCREEN - retrieves saved screen
PRESSED - returns next key (inc. extended ASCII, function keys, etc.)
(usage:
var key: keytype;
begin
key:= pressed;
if key.reg=chr(27) then do_escape
else if key.ex=35 {alt H} then do_help
else...)
To use the whole package, compile it as a unit, $include the interface and
put a "uses TOOLS" statement in your program heading. If you only need a few
of the functions and procedures, put the declarations back on the ones you
need and $include just the code you need in your program. Please include the
statement "copyright 1984 Ronald Florence" in any program incorporating these
procedures and functions.
Good luck. If you make any useful additions or changes, please write me:
Ronald Florence
114 Five Mile River Road
Darien, CT 06820
}
interface;
unit tools
(wrxy, doxy, cls, locate, cursor_row, cursor_col,
inkey, escape, rdchar, yes, upcase, rdint, rdreal, rdstr,
peek, poke, ok_disp, pushscreen, popscreen, pressed);
type
charset = set of char;
keytype = record
ex: byte;
reg: char
end;
procedure wrxy (const msg: lstring; row, col: sint; att: char);
procedure doxy (ch: char; row, col: sint; att: char; len:sint);
procedure cls (upper, lower: sint);
procedure locate (y,x: sint);
function cursor_row: sint;
function cursor_col: sint;
function inkey: char;
function escape: boolean;
function rdchar (okchars:charset): char;
function yes: boolean;
procedure upcase (var s: string);
function rdstr (var s: string): boolean;
function rdint (var i:integer; low, high: integer): boolean;
function rdreal (var r:real): boolean;
function peek (segment, offset: word): byte;
procedure poke (segment, offset: word; argval: byte);
function ok_disp: boolean;
procedure pushscreen;
procedure popscreen;
function pressed: keytype;
end;
implementation of tools;
type
screenchar = record
character, attribute: char;
end;
screentype = array [1..25, 1..80] of screenchar;
curs_pos = record
col, row: byte;
end;
const
blank = ' ';
norm = chr(7);
var [static]
screen: ads of screentype;
curs : ads of curs_pos;
cls_start: ads of char;
video_ads: word;
snapscreen : ^screentype;
snapcurs : curs_pos;
value
curs.s:= #0040;
curs.r:= #0050;
screen.r:= #0;
procedure ptyuqq (len:word; loc:adsmem); extern;
function dosxqq (comm, parm: word): byte; extern;
procedure wrxy;
var [static]
i: sint;
begin
for i := 1 to ord(msg.len) do begin
screen^[row, col].character := msg[i];
screen^[row, col].attribute := att;
col := col+1
end
end;
procedure doxy;
var [static]
i: sint;
begin
for i := 1 to len do begin
screen^[row, col].character := ch;
screen^[row, col].attribute := att;
col := col+1
end;
end;
procedure cls;
type
screenline = array [1..80] of screenchar;
var [static]
blankline: screenline;
value
blankline:= screenline (do 80 of screenchar (blank, norm));
begin
cls_start.r:= 160 * wrd(upper-1);
for var line:= upper to lower do
[movesl (ads blankline, cls_start, 160);
cls_start.r:= cls_start.r + 160]
end;
procedure locate;
const
bs = chr(8);
begin
curs^.col:= wrd(x);
curs^.row:= wrd(y-1);
ptyuqq (1, ads bs)
end;
function cursor_row;
begin
cursor_row:= ord(curs^.row + 1)
end;
function cursor_col;
begin
cursor_col:= ord (curs^.col + 1)
end;
function inkey;
var
b: byte;
begin
repeat b:= dosxqq(6,255) until b <> 0;
inkey:= chr(b)
end;
function escape;
var
b: byte;
begin
b:= dosxqq(6,255);
escape:= b=27
end;
function rdchar;
var
c: char;
begin
repeat
c:= inkey;
if c in ['a'..'z'] then c:= chr (ord(c) - 32)
until c in okchars;
write (c);
rdchar:= c
end;
function yes;
var
c: char;
begin
repeat c:= inkey until c in ['y','Y','n','N'];
write (c);
yes:= c in ['y','Y']
end;
procedure upcase;
begin
for var c:= 1 to upper(s) do
if s[c] in ['a'..'z'] then s[c]:= chr(ord(s[c])-32)
end;
function rdstr;
label
again;
var
c: char;
k: sint;
begin
again:
k:= 1;
repeat
c:= inkey;
case c of
chr(8): if k > 1 then begin
write (chr(8)*blank*chr(8));
s[k]:= blank;
k:= k-1
end;
chr(27): if k = 1 then begin
rdstr:= false;
return
end
else begin
for var d:= 1 to k do s[d]:= blank;
doxy (blank, cursor_row, cursor_col-k+1, norm, k-1);
locate (cursor_row, cursor_col-k+1);
goto again
end;
chr(32)..chr(126): if k <= upper(s) then
begin
write (c);
s[k]:= c;
k:= k+1
end
else write (chr(7))
otherwise
end
until c=chr(13);
if k < upper(s) then for var d:= k to upper(s) do s[d]:= blank;
rdstr:= true
end;
function rdint;
label
again;
var
neg: boolean;
k: sint;
c: char;
begin
again:
k:= 1;
i:= 0;
neg:= false;
repeat
c:= inkey;
case c of
chr(45): if k=1 then begin
write (c);
neg:= true;
k:= k+1
end
else write (chr(7));
'0'..'9': begin
write (c);
i:= i * 10 + ord(c) - ord('0');
k:= k+1
end;
chr(8) : if k > 1 then begin
write (chr(8)*blank*chr(8));
if neg and (k=2) then neg:= false
else i:= i div 10;
k:= k-1;
end;
chr (13): ;
chr(27): if k = 1 then begin
rdint:= false;
return
end
else begin
doxy (blank, cursor_row, cursor_col-k+1, norm, k-1);
locate (cursor_row, cursor_col-k+1);
goto again
end;
otherwise write (chr(7))
end
until c = chr(13);
if neg then i:= - i;
if (i < low) or (i > high) then begin
write (chr(7));
doxy (blank, cursor_row, cursor_col-k+1, norm, k-1);
locate (cursor_row, cursor_col-k+1);
goto again
end
else rdint:= true
end;
function rdreal;
label
again;
var
left, right: integer4;
expon: real;
neg, decimal : boolean;
k: sint;
c: char;
begin
again:
k:= 1;
expon:= 1;
left:= 0;
right:= 0;
neg:= false;
decimal:= false;
repeat
c:= inkey;
case c of
chr(45): if k=1 then begin
write (c);
neg:= true;
k:= k+1
end
else write (chr(7));
chr(46): if not decimal then begin
write (c);
decimal:= true;
k:= k+1;
end
else write (chr(7));
'0'..'9': begin
write (c);
if not decimal then begin
left:= left * 10 + ord(c) - ord('0');
k:= k+1
end
else begin
right:= right * 10 + ord (c) - ord ('0');
expon:= expon / 10;
k:= k+1
end
end;
chr(8) : if k > 1 then begin
write (chr(8)*blank*chr(8));
if neg and (k=2) then neg:= false
else if not decimal then left:= left div 10
else if decimal and (expon=1) then decimal:= false
else begin
right:= right div 10;
expon:= expon * 10
end;
k:= k-1
end;
chr (13): ;
chr(27): if k = 1 then begin
rdreal:= false;
return
end
else begin
doxy (blank, cursor_row, cursor_col-k+1, norm, k-1);
locate (cursor_row, cursor_col-k+1);
goto again
end;
otherwise write (chr(7))
end;
until c = chr(13);
r:= left + expon * float4(right);
if neg then r:= - r;
rdreal:= true
end;
function peek;
var addr: ads of byte;
begin
addr.s:= segment;
addr.r:= offset;
peek:= addr^
end;
procedure poke;
var addr: ads of byte;
begin
addr.s:= segment;
addr.r:= offset;
addr^:= argval
end;
function ok_disp;
begin
case peek(#0040, #0049) of
7 : video_ads:= #B000; {monochrome board}
2,3: video_ads:= #B800 {80 col graphics board}
otherwise
[writeln ('Program requires 80 column text display');
ok_disp:= false;
return]
end;
screen.s:= video_ads;
cls_start.s:= video_ads;
ok_disp:= true
end;
procedure pushscreen;
var
oldscreen : ads of byte;
begin
oldscreen.s := video_ads;
oldscreen.r := 0;
new(snapscreen);
movesl(oldscreen, ads snapscreen^, 4000);
snapcurs.row:= wrd(cursor_row);
snapcurs.col:= wrd(cursor_col)
end;
procedure popscreen;
var
oldscreen : ads of byte;
begin
oldscreen.s := video_ads;
oldscreen.r := 0;
movesl(ads snapscreen^, oldscreen, 4000);
locate (ord(snapcurs.row), ord(snapcurs.col));
dispose(snapscreen)
end;
function pressed;
var
b: byte;
begin
b:= dosxqq (7, 0);
pressed.reg:= chr(b);
if b <> 0 then pressed.ex:= 0
else pressed.ex:= dosxqq (7, 0)
end;
end.